ruta_productos <- "C:\\Users\\Usuario\\Downloads\\ARCHIVOS DE POSIT\\PRODUCTOS_2025.xlsx"
#"/cloud/project/PRODUCTOS_2025.xlsx"
excel_sheets(ruta_productos)
## [1] "Sheet 1"
Productos2025 <- as.data.frame(read_xlsx(ruta_productos, sheet ="Sheet 1"))
Productos2025$Semana <- format(Productos2025$Fecha, format ="%Y-%U")
Fecha2025 <- Productos2025$Fecha
Productos2025 <- Productos2025 %>%
group_by(Fecha = as.Date(Fecha)) %>%
summarize(Totales = sum(Totales),
.groups = "keep")
head(Productos2025)
## # A tibble: 6 × 2
## # Groups: Fecha [6]
## Fecha Totales
## <date> <dbl>
## 1 2024-12-07 2926.
## 2 2025-01-03 2466.
## 3 2025-01-08 1672.
## 4 2025-01-09 7273.
## 5 2025-01-10 20880
## 6 2025-01-11 8352
tail(Productos2025)
## # A tibble: 6 × 2
## # Groups: Fecha [6]
## Fecha Totales
## <date> <dbl>
## 1 2025-02-24 14240.
## 2 2025-02-27 20630.
## 3 2025-03-06 66800.
## 4 2025-03-31 42850.
## 5 2025-04-08 4749.
## 6 2025-04-16 923.
nrow(Productos2025)
## [1] 32
productoss_2025_ts <- ts(Productos2025$Totales,start =1, frequency =1)
productoss_2025_xts <- as.xts(productoss_2025_ts)
## Datos historicos de productos
ruta <- "C:\\Users\\Usuario\\Downloads\\ARCHIVOS DE POSIT\\Ventas_Suministros_Totales.xlsx"
excel_sheets(ruta)
## [1] "Ventas Totales Original" "Servicios Totales Original"
# "Ventas Totales Original" "Servicios Totales Original"
Productos_Totales <- as.data.frame(read_xlsx(ruta,
sheet = "Ventas Totales Original"))
Productos_Totales$Semana <- format(Productos_Totales$Fecha, format = "%Y-%U")
Productos_Totales$mes <- format(Productos_Totales$Fecha, format = "%Y-%m")
head(Productos_Totales)
## Folio Fecha RFC Empresa
## 1 1 2019-07-01 10:01:03 VEPS740807T84 Silvia Elena Velasco Palacios
## 2 2 2019-07-01 11:40:32 CERI890615EU1 ISRAEL CETINA ROSALES
## 3 2 2019-07-01 11:40:32 CERI890615EU1 ISRAEL CETINA ROSALES
## 4 2 2019-07-01 11:40:32 CERI890615EU1 ISRAEL CETINA ROSALES
## 5 2 2019-07-01 11:40:32 CERI890615EU1 ISRAEL CETINA ROSALES
## 6 2 2019-07-01 11:40:32 CERI890615EU1 ISRAEL CETINA ROSALES
## Cantidad Unidad
## 1 1 Bidón de plástico
## 2 1 Pieza
## 3 1 Pieza
## 4 1 Pieza
## 5 1 Pieza
## 6 1 Pieza
## Descripcion ValorUnitario
## 1 Algicin marca Spin en presentación de garrafa de 20 Litros 700.00
## 2 Kit de Sello y espaciadores Piston Superior 308.04
## 3 Kit de sello y espaciadores Piston Inferior 811.78
## 4 Kit Piston Superior 9000/9100 968.58
## 5 Kit Piston Inferior 9000/9100 1784.38
## 6 Engrane motriz Inferior 9100 1092.00
## Total Semana mes
## 1 812.0000 2019-26 2019-07
## 2 357.3264 2019-26 2019-07
## 3 941.6648 2019-26 2019-07
## 4 1123.5528 2019-26 2019-07
## 5 2069.8808 2019-26 2019-07
## 6 1266.7200 2019-26 2019-07
nrow(Productos_Totales)
## [1] 1995
productos <- data.frame(Fecha = Productos_Totales$Fecha, Totales = Productos_Totales$Total)
productos <- productos %>%
group_by(Fecha = as.Date(Fecha)) %>%
summarize(Totales = sum(Totales),
.groups = "keep")
head(productos)
## # A tibble: 6 × 2
## # Groups: Fecha [6]
## Fecha Totales
## <date> <dbl>
## 1 2019-07-01 25826.
## 2 2019-07-03 3138.
## 3 2019-07-04 5330.
## 4 2019-07-05 10146.
## 5 2019-07-06 10962
## 6 2019-07-08 16194.
nrow(productos)
## [1] 695
nrow(productos)
## [1] 695
productos_ts <- ts(productos$Totales, start = 1, frequency = 1)
PRODTOTAL <- merge(x = productos, y = Productos2025, all = T)
head(PRODTOTAL)
## Fecha Totales
## 1 2019-07-01 25826.333
## 2 2019-07-03 3137.800
## 3 2019-07-04 5329.713
## 4 2019-07-05 10145.534
## 5 2019-07-06 10962.000
## 6 2019-07-08 16193.600
tail(PRODTOTAL)
## Fecha Totales
## 722 2025-02-24 14240.16
## 723 2025-02-27 20630.00
## 724 2025-03-06 66799.76
## 725 2025-03-31 42850.40
## 726 2025-04-08 4749.04
## 727 2025-04-16 923.36
nrow(PRODTOTAL)
## [1] 727
prodsem_ts <- ts(PRODTOTAL$Totales, start = c(2019,07,01),
end = c(2025,04,16),frequency = 52)
PRODTOTAL$Semana <- format(PRODTOTAL$Fecha, format = "%Y-%U")
lambda <- boxcox(x = as.numeric(prodsem_ts), objective.name = "Log-Likelihood", optimize = T)
lambda$lambda
## [1] 0.03181016
# [1] 0.03181016
PS <- boxcoxTransform(x = as.numeric(prodsem_ts), lambda = lambda$lambda )
head(PS)
## [1] 11.992777 9.176249 9.866464 10.720959 10.824884 11.352690
tail(PS)
## [1] 12.368630 9.370100 10.515330 11.702842 12.658879 9.612385
ts_plot(serie_semana_prod, color = "blue", Xtitle = "Semanas", Ytitle = "Valores", title = " Serie semanal de productos")
ndiffs(serie_semana_prod)
## [1] 0
LSTAR_PS <- lstar(x = serie_semana_prod, m = 11)
## Using maximum autoregressive order for low regime: mL = 11
## Using maximum autoregressive order for high regime: mH = 11
## Using default threshold variable: thDelay=0
## Performing grid search for starting values...
## Starting values fixed: gamma = 100 , th = 10.69711 ; SSE = 836.4362
## Grid search selected lower/upper bound gamma (was: 1 100 ]).
## Might try to widen bound with arg: 'starting.control=list(gammaInt=c(1,200))'
## Optimization algorithm converged
## Optimized values fixed for regime 2 : gamma = 100.0011 , th = 10.69386 ; SSE = 836.4204
summary(LSTAR_PS)
##
## Non linear autoregressive model
##
## LSTAR model
## Coefficients:
## Low regime:
## const.L phiL.1 phiL.2 phiL.3 phiL.4 phiL.5
## 2.974868838 0.063487520 -0.041369311 0.068235856 0.079083602 0.171904910
## phiL.6 phiL.7 phiL.8 phiL.9 phiL.10 phiL.11
## 0.033047705 -0.010511002 -0.008069573 0.113793333 0.192160578 0.067601517
##
## High regime:
## const.H phiH.1 phiH.2 phiH.3 phiH.4 phiH.5
## 13.31016401 -0.17027080 0.04944138 -0.07778873 -0.14415242 -0.24875581
## phiH.6 phiH.7 phiH.8 phiH.9 phiH.10 phiH.11
## -0.21228488 0.05456323 0.06367833 -0.29062782 -0.37851561 0.05065561
##
## Smoothing parameter: gamma = 100
##
## Threshold
## Variable: Z(t) = + (1) X(t) + (0) X(t-1)+ (0) X(t-2)+ (0) X(t-3)+ (0) X(t-4)+ (0) X(t-5)+ (0) X(t-6)+ (0) X(t-7)+ (0) X(t-8)+ (0) X(t-9)+ (0) X(t-10)
##
## Value: 10.69
##
## Residuals:
## Min 1Q Median 3Q Max
## -4.535384 -1.277977 0.062404 1.089145 5.880050
##
## Fit:
## residuals variance = 2.698, AIC = 360, MAPE = 13.95%
##
## Coefficient(s):
## Estimate Std. Error t value Pr(>|z|)
## const.L 2.9748688 2.1481983 1.3848 0.1661074
## phiL.1 0.0634875 0.1093727 0.5805 0.5615981
## phiL.2 -0.0413693 0.0733752 -0.5638 0.5728866
## phiL.3 0.0682359 0.0713535 0.9563 0.3389170
## phiL.4 0.0790836 0.0696404 1.1356 0.2561244
## phiL.5 0.1719049 0.0732089 2.3481 0.0188673 *
## phiL.6 0.0330477 0.0749415 0.4410 0.6592275
## phiL.7 -0.0105110 0.0714107 -0.1472 0.8829814
## phiL.8 -0.0080696 0.0739573 -0.1091 0.9131143
## phiL.9 0.1137933 0.0731767 1.5550 0.1199344
## phiL.10 0.1921606 0.0717323 2.6789 0.0073874 **
## phiL.11 0.0676015 0.0692452 0.9763 0.3289341
## const.H 13.3101640 4.0967207 3.2490 0.0011582 **
## phiH.1 -0.1702708 0.1925419 -0.8843 0.3765175
## phiH.2 0.0494414 0.1114013 0.4438 0.6571775
## phiH.3 -0.0777887 0.1140504 -0.6821 0.4952037
## phiH.4 -0.1441524 0.1146889 -1.2569 0.2087900
## phiH.5 -0.2487558 0.1116973 -2.2271 0.0259437 *
## phiH.6 -0.2122849 0.1130991 -1.8770 0.0605206 .
## phiH.7 0.0545632 0.1130474 0.4827 0.6293387
## phiH.8 0.0636783 0.1120675 0.5682 0.5698896
## phiH.9 -0.2906278 0.1140251 -2.5488 0.0108093 *
## phiH.10 -0.3785156 0.1128403 -3.3544 0.0007953 ***
## phiH.11 0.0506556 0.1154381 0.4388 0.6607977
## gamma 100.0010998 182.3116034 0.5485 0.5833366
## th 10.6938621 0.0459660 232.6474 < 2.2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Non-linearity test of full-order LSTAR model against full-order AR model
## F = 1.1492 ; p-value = 0.32301
##
## Threshold
## Variable: Z(t) = + (1) X(t) + (0) X(t-1)+ (0) X(t-2)+ (0) X(t-3)+ (0) X(t-4)+ (0) X(t-5)+ (0) X(t-6)+ (0) X(t-7)+ (0) X(t-8)+ (0) X(t-9)+ (0) X(t-10)
checkresiduals(LSTAR_PS, col = "darkgreen")
##
## Ljung-Box test
##
## data: Residuals
## Q* = 0.60409, df = 10, p-value = 1
##
## Model df: 0. Total lags used: 10
AIC(LSTAR_PS)
## [1] 359.6933
fsem <- predict(LSTAR_PS, n.ahead = length(serie_semana_prod[297:310]))
fsem <- data.frame(pronosticos = fsem)
head(fsem)
## pronosticos
## 1 10.453485
## 2 10.710614
## 3 10.006611
## 4 11.421939
## 5 9.917958
## 6 10.382316
tail(fsem)
## pronosticos
## 9 11.04110
## 10 10.48856
## 11 10.47347
## 12 10.61219
## 13 10.55269
## 14 10.76535
nrow(fsem)
## [1] 14
accuracy(fsem$pronosticos, serie_semana_prod[297:310])
## ME RMSE MAE MPE MAPE
## Test set 0.3555935 1.408671 1.14663 1.794215 10.46652
errores_prod_semana <- residuals(LSTAR_PS)
sd_errores_prod_semana <- sd(errores_prod_semana, na.rm =T)
margen_error_prod_semana <- sd_errores_prod_semana * qnorm(0.975)
fsem$inf <- fsem$pronosticos - margen_error_prod_semana
fsem$sup <- fsem$pronosticos + margen_error_prod_semana
head(fsem)
## pronosticos inf sup
## 1 10.453485 7.169870 13.73710
## 2 10.710614 7.426999 13.99423
## 3 10.006611 6.722996 13.29023
## 4 11.421939 8.138324 14.70555
## 5 9.917958 6.634343 13.20157
## 6 10.382316 7.098701 13.66593
tail(fsem)
## pronosticos inf sup
## 9 11.04110 7.757480 14.32471
## 10 10.48856 7.204943 13.77217
## 11 10.47347 7.189856 13.75709
## 12 10.61219 7.328576 13.89581
## 13 10.55269 7.269080 13.83631
## 14 10.76535 7.481738 14.04897
nrow(fsem)
## [1] 14
fsem
## pronosticos inf sup
## 1 10.453485 7.169870 13.73710
## 2 10.710614 7.426999 13.99423
## 3 10.006611 6.722996 13.29023
## 4 11.421939 8.138324 14.70555
## 5 9.917958 6.634343 13.20157
## 6 10.382316 7.098701 13.66593
## 7 10.763715 7.480100 14.04733
## 8 9.513339 6.229724 12.79695
## 9 11.041095 7.757480 14.32471
## 10 10.488558 7.204943 13.77217
## 11 10.473471 7.189856 13.75709
## 12 10.612191 7.328576 13.89581
## 13 10.552695 7.269080 13.83631
## 14 10.765353 7.481738 14.04897
## Comprobación
datos <- data.frame(prediccion = as.numeric(fsem$pronosticos), valores_reales = serie_semana_prod[297:310], limite_sup = as.numeric(fsem$sup), limite_inf = as.numeric(fsem$inf))
datos
## prediccion valores_reales limite_sup limite_inf
## 1 10.453485 12.634296 13.73710 7.169870
## 2 10.710614 8.436725 13.99423 7.426999
## 3 10.006611 9.894040 13.29023 6.722996
## 4 11.421939 12.396898 14.70555 8.138324
## 5 9.917958 10.186424 13.20157 6.634343
## 6 10.382316 10.150551 13.66593 7.098701
## 7 10.763715 10.116112 14.04733 7.480100
## 8 9.513339 12.038439 12.79695 6.229724
## 9 11.041095 12.368630 14.32471 7.757480
## 10 10.488558 9.370100 13.77217 7.204943
## 11 10.473471 10.515330 13.75709 7.189856
## 12 10.612191 11.702842 13.89581 7.328576
## 13 10.552695 12.658879 13.83631 7.269080
## 14 10.765353 9.612385 14.04897 7.481738
valores_reales <- InvBoxCox(x = datos, lambda = 0.03181016)
valores_reales
## prediccion valores_reales limite_sup limite_inf
## 1 8305.728 40950.559 89062.16 638.1383
## 2 10067.565 1760.880 106459.46 786.2199
## 3 5928.584 5442.721 65157.32 442.5489
## 4 17038.089 34555.524 173497.49 1390.5041
## 5 5542.612 6792.961 61217.44 411.3447
## 6 7873.405 6611.305 84755.31 602.1759
## 7 10474.051 6441.342 110441.62 820.7023
## 8 4068.895 26693.762 45978.73 293.9868
## 9 12869.433 33861.797 133702.59 1026.0078
## 10 8527.148 3644.488 91261.81 656.6173
## 11 8431.208 8699.998 90309.22 648.6056
## 12 9354.165 20922.389 99443.04 725.9793
## 13 8946.922 41674.770 95421.05 691.7579
## 14 10486.838 4389.939 110566.71 821.7889
##n Gráfica de los valores